Celestin Apprentice 4

home *** CD-ROM | disk | FTP | other *** search

/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / Toolbox classes / Scroller < prev next >

Wrap

Text File | 1995-11-26 | 14.9 KB | 508 lines | [TEXT/MSET]

\ Scroller - view which supports scroll bars. \ May 91 mrh Added horizontal scroll bar support. \ Oct 91 mrh Changed owner from Window to View. Replaces vscroll \ May 92 mrh Changed to "new-style" control. \ June 92 mrh Fixed GetRect: in Scroller. \ Feb 93 mrh Introduced class BigRect for PanRects, to allow humungous rects. \ Sept 93 mrh Revised for new control scheme - controls now a view subclass. \ Nov95 JRF now properly hiding and showing scrollbars need view need ctl \ SCROLLER is a view which has support for a vertical and horizontal \ scroll bar along the right hand and bottom edge respectively. We implement \ it with three child views: mainView, which is the display area, and the \ two scroll bars themselves. \ MainView is an instance of a one-off class, Mview. This class has a \ rectangle, PanRect, which normally ought to enclose all the child views \ of the Mview. The usual scenario is that PanRect is larger than the viewRect, \ and scrolling amounts to shifting the child views (and PanRect) around within \ the viewRect - which, from another point of view, can be thought of as \ "panning" the viewRect over the PanRect area. \ Mview has appropriate methods for returning the distances by which PanRect \ falls outside the viewRect area, so that the parent Scroller can set the \ scroll bar values appropriately. \ One unusual thing we do here is to override addView: on Scroller so that it \ becomes an ADDVIEW: on MainView, since this is usually what we really mean. \ In the case where you want to really addView: on the Scroller, such as to add \ another child view alongside one of the scroll bars, you should subclass \ Scroller with the extra views as ivars, and at run time do addView: super \ as we do for the scroll bars (see the NEW: method). \ Another approach we could have taken to implementing MainView would have been \ as a pointer, with late binding. That way MainView could have been any \ view subclass. That would have been more flexible, but possibly overkill \ for what we usually want to do - it would have required a more complex \ setting-up process, with the MainView address having to be passed in after \ NEW: has been done. But if you need the extra flexibility, feel free to clone \ Scroller and make the changes! \ PanRect can obviously be very big, so we don't implement it as a regular rect, \ but define a new class, BigRect, which uses vars rather than ints for the \ coordinates. 0 value ClickedScroller \ CLICK: on a Scroller puts the Scroller's addr here, so \ child views can easily send messages back to the clicked \ Scroller. Scroll bars use this, also TextEdit views. \ I could have just used ThisCtl, but if another control \ is involved somewhere it might get clobbered. Unlikely, \ but I'm a cautious individual. : 1R 1Right: [ clickedScroller ] ; : 1L 1Left: [ clickedScroller ] ; : 1U 1Up: [ clickedScroller ] ; : 1D 1Down: [ clickedScroller ] ; : PGR pgRight: [ clickedScroller ] ; : PGL pgLeft: [ clickedScroller ] ; : PGU pgUp: [ clickedScroller ] ; : PGD pgDown: [ clickedScroller ] ; : VD Vdrag: [ clickedScroller ] ; : HD Hdrag: [ clickedScroller ] ; \ ================= BigRect =================== \ BIGRECT is exactly that -- using vars rather than ints for the \ coordinates. The toolbox doesn't support this, so we just use \ it in places where we need very big rectangles and control \ everything ourselves. So far we only need to support GET:, PUT: \ and SHIFT: methods. :class BIGRECT super{ object } record { var TOP var LEFT var BOTTOM var RIGHT } :m GET: get: left get: top get: right get: bottom ;m :m PUT: put: bottom put: right put: top put: left ;m :m SHIFT: { dx dy -- } dx dy or 0EXIT dx +: left dx +: right dy +: top dy +: bottom ;m :m INSET: { dx dy -- } dx +: left dx -: right dy +: top dy -: bottom ;m ;class \ ================= Mview =================== \ MVIEW is a view which we use for the main view of a Scroller (the view \ with the actual contents - the other two views are the two scroll \ bars). It has methods to shift its children, or, depending on \ the point of view, "panning" over the children. :class MVIEW super{ view } record { bigrect PANRECT \ Rect for "panning" children. Ought to \ contain all of them. Can be enormous. } :m GETPANRECT: get: panRect ;m :m PUTPANRECT: put: panRect ;m \ SHIFTCHILDREN ( dx dy -- ) moves all the child views by \ the given distance. We do this by changing their bounds appropriately \ then calling MOVED:. :m SHIFTCHILDREN: { dx dy \ theChild l t r b -- } BEGIN each: children WHILE -> theChild theChild getBounds: view -> b -> r -> t -> l dx ++> l dx ++> r dy ++> t dy ++> b l t r b theChild setBounds: view moved: [ theChild ] \ late bind here as different things may happen REPEAT ;m private :m HowFar: { offs1 offs2 -- offs' } offs1 offs2 xor 0> \ Same sign? IF offs1 offs2 dup 0< IF max else min THEN ELSE 0 THEN ;m \ CoercePanRect: shifts the children so that panRect falls as far \ within the viewRect as possible. We factor out (CoercePanRect): \ which does the basic stuff that Scroller subclasses can use. public :m (CoercePanRect): { \ pLeft pTop pRt pBot dx dy -- dx dy } \ Returns the amount we have to shift panRect to get it into \ the right position. We pass in panRect's coordinates so that \ Scroller subclasses can use a different panRect (TEScroller \ does this). get: panRect -> pBot -> pRt -> pTop -> pLeft getTopX: viewRect pLeft - getBotX: viewRect pRt - howFar: self -> dx getTopY: viewRect pTop - getBotY: viewRect pBot - howFar: self -> dy dx dy shift: panRect dx dy ;m :m CoercePanRect: { \ dx dy -- } (coercePanRect): self -> dy -> dx dx dy or 0EXIT dx dy shiftChildren: self ;m \ Here we define the default panRect to be the rect which just contains \ all the child views. Change as necessary. :m DfltPanRect: { \ left top rt bot -- } first?: children NIF 0 -> bot 0 -> rt 0 -> top 0 -> left ELSE getRect: [] -> bot -> rt -> top -> left THEN BEGIN each: children WHILE getRect: [] bot max -> bot rt max -> rt top min -> top left min -> left REPEAT left top rt bot put: panRect ;m ;class \ ================= Scroller =================== \ SCROLLER is a view which has support for a vertical and horizontal \ scroll bar along the right hand and bottom edge respectively. \ Either may be present or absent, and may have an offset or gap \ at either end of a specified amount. :class SCROLLER super{ view } mview MainView \ The display area, minus the scroll bars vscroll TheVscroll hscroll TheHscroll record { bool vscroll? \ True if v scroll bar to be used bool hscroll? \ True if h scroll bar to be used bool UsePanRect? \ True if we're to use PanRect var HPAN \ Horizontal panning range var HPOS \ Current vertical posn var VPAN \ Vertical ditto var VPOS int HUNIT \ # pixels for one horizontal arrow click int VUNIT } :m SetPanRanges: { \ left top rt bot pLeft pTop pRt pBot -- } noClip getViewRect: mainView -> bot -> rt -> top -> left getPanRect: mainView -> pBot -> pRt -> pTop -> pLeft left pLeft - dup 0 max put: Hpos pRt rt - + 0 max put: Hpan top pTop - dup 0 max put: Vpos pBot bot - + 0 max put: Vpan get: vscroll? IF 0 get: vpan putRange: theVscroll get: vpan IF get: vpos put: theVscroll enable: theVscroll ELSE 0 put: theVscroll disable: theVscroll THEN THEN get: hscroll? IF 0 get: hpan putRange: theHscroll get: hpan IF get: hpos put: theHscroll enable: theHscroll ELSE 0 put: theHscroll disable: theHscroll THEN THEN ;m :m FixPanRect: get: usePanRect? NIF dfltPanRect: mainView THEN coercePanRect: mainView setPanRanges: self ;m :m FixMainViewBounds: getBounds: mainView 2drop \ Don't change left or top -16 get: vscroll? and -16 get: hscroll? and setBounds: mainView ;m :m FixHscrollBounds: -1 -16 -15 0 \ ****get: vscroll? and 0 Nov95 JRF \ JRF moved left 1 pixel to left setBounds: theHscroll moved: theHscroll ;m :m FixVscrollBounds: -16 -1 0 -15 \ ****get: hscroll? and \ JRF moved top up 1 pixel setBounds: theVscroll moved: theVscroll ;m public ( b -- ) :m VSCROLL: put: vscroll? fixMainViewBounds: self ;m :m HSCROLL: put: hscroll? fixMainViewBounds: self ;m :m PUTPANRECT: ( l t r b -- ) putPanRect: mainView true put: usePanRect? coercePanRect: mainView setPanRanges: self ;m :m ADDVIEW: addView: mainView ;m ( n -- ) :m >HUNIT: put: Hunit ;m :m >VUNIT: put: Vunit ;m :m >VRANGE: putRange: theVscroll ;m :m >HRANGE: putRange: theHscroll ;m :m ?VENABLE: get: vscroll? 0EXIT show: theVscroll \ Nov95 JRF now properly hiding and showing scrollbars get: Vpan 0EXIT enable: theVscroll ;m :m ?HENABLE: get: hscroll? 0EXIT show: theHscroll \ Nov95 JRF get: Hpan 0EXIT enable: theHscroll ;m :m NEW: \ mainView and the 2 scroll bars are ivars, but they have to be \ children as well! addr: mainView addView: super get: hscroll? IF addr: theHscroll addView: super THEN get: vscroll? IF addr: theVscroll addView: super THEN new: super fixHscrollBounds: self fixVscrollBounds: self fixPanRect: self ;m :m ENABLE: get: alive? 0EXIT ?Venable: self ?Henable: self enable: super ;m :m DISABLE: get: alive? 0EXIT get: vscroll? if disable: theVscroll hide: theVscroll then \ JRF get: hscroll? if disable: theHscroll hide: theHscroll then \ JRF disable: super ;m :m MOVED: moved: super fixPanRect: self update: self ;m \ PAN: ( dx dy -- ) pans the view over the subviews by the given distance. \ Doesn't alter the scroll bars -- use PANRIGHT: etc. for this, since they \ adjust the appropriate scroll bar and then call PAN:. \ Our convention is that positive dx and dy correspond to a pan to the \ right and down, which means that the subviews are being shifted to the \ left and up, which is a "negative" shift. It's very easy to get this \ mixed up, but it would be just as confusing if I did it the other way \ around. If something doesn't work, try reversing the signs!! \ Another point to note is that I've found by experimentation that if \ the mouse is held down in a scroll bar arrow, our arrow routine, which \ is passed to TrackControl as a proc, gets called continually -- thus we \ can't handle an update event on the window are until mouse-up. I'm not \ even sure there is an update event until then, anyway. \ I guess Apple's idea is that each time the origin should get \ shifted, so that the little rectangles which are invalidated each time \ get accumulated properly. But in our way of doing things, we're using \ the grafport origin all the time (until a DRAW: is done), so the same \ rectangle would get invalidated repeatedly. So we handle this with an \ ivar, #updates. If we get a PAN: call and #updates is zero, we call \ InvalRect as normal. If #updates is 1, the little rectangle will already \ be invalid, but rather than trying to invalidate an adjacent rectangle \ we take the easy way out and invalidate the whole viewRect. At least \ that way we can be sure we don't miss updating something. If #updates \ is greater than 2, we've already invalidated the viewRect, so there's \ nothing left to do -- so that's exactly what we do. \ Another point that has come out through experimentation is that the \ scroll bar which has had its arrow clicked must not be clipped out, or \ the thumb isn't redrawn in the right position. The redraw is done by \ the system, but mustn't be clipped out. So we set the clip to the right \ contents area with ClipRect, scroll the rectangle, then at the end set \ the clip to the rect containing the appropriate scroll bar so that the \ system will redraw it properly. :m PAN: { dx dy \ #upd hext vext -- } dx +: hpos dy +: vpos neg> dx neg> dy ^viewRect: mainView dup call ClipRect dx dy pack theRgn call ScrollRect get: #updates -> #upd #upd 1+ 100 min put: #updates #upd NIF theRgn call InvalRgn false put: setClip? ELSE #upd 1 = IF ^viewRect: mainView call InvalRect THEN THEN dx dy shiftChildren: mainView noClip ;m \ Note: it turns out we need the noClip so that the scroll bar arrow \ always unhilites. :m PANRIGHT: { dx \ hs -- } get: theHscroll -> hs hs dx + get: Hpan > IF get: Hpan hs - -> dx THEN dx 0EXIT hs dx + put: theHscroll dx 0 pan: self ;m :m PANLEFT: { dx \ hs -- } get: theHscroll -> hs hs 0EXIT hs dx - 0< if hs -> dx then hs dx - put: theHscroll dx negate 0 pan: self ;m :m PANDOWN: { dy \ vs -- } get: theVscroll -> vs vs dy + get: Vpan > IF get: Vpan vs - -> dy THEN dy 0EXIT vs dy + put: theVscroll 0 dy pan: self ;m :m PANUP: { dy \ vs -- } get: theVscroll -> vs vs 0EXIT vs dy - 0< IF vs -> dy THEN vs dy - put: theVscroll 0 dy negate pan: self ;m :m HPAGE: { \ left top rt bot -- #pixels } get: viewRect -> bot -> rt -> top -> left rt left - get: Hunit - 0 max ;m :m VPAGE: { \ left top rt bot -- #pixels } get: viewRect -> bot -> rt -> top -> left bot top - get: Vunit - 0 max ;m :m 1RIGHT: get: Hunit panRight: self ;m :m 1LEFT: get: Hunit panLeft: self ;m :m 1UP: get: Vunit panUp: self ;m :m 1DOWN: get: Vunit panDown: self ;m :m PGRIGHT: hPage: self panRight: self ;m :m PGLEFT: hPage: self panLeft: self ;m :m PGUP: vPage: self panUp: self ;m :m PGDOWN: vPage: self panDown: self ;m :m VDRAG: 0 get: theVscroll get: vpos - pan: self ;m :m HDRAG: get: theHscroll get: hpos - 0 pan: self ;m \ The CLICK: method only has to do one extra thing over what View \ provides - we put the addr of this Scroller in clickedScroller so the \ scroll bar action handlers can send messages back to us. :m CLICK: ^base -> clickedScroller click: super ;m :m CLASSINIT: classinit: super true vscroll: self true hscroll: self \ Defaults 4 dup put: Hunit put: Vunit XTS{ 1l 1r pgl pgr hd } actions: theHscroll XTS{ 1u 1d pgu pgd vd } actions: theVscroll parRight parTop parRight parBottom setJust: theVscroll parLeft parBottom parRight parBottom setJust: theHscroll parLeft parTop parRight parBottom setJust: mainView ;m ;class endload \ Testing - this sets up a Scroller. scroller SS button BB \ A child view which is a button 40 40 300 200 setBounds: ss 10 10 " Click here" init: bb : Drawit draw: tempRect ; \ A draw handler which just draws the viewRect : DrawSS draw: ss ; \ Draw handler for fWind for test : Clicked noclip ." clicked " .id: [self] cr \ Now we expand ss a bit to check if the scroll bars move and resize: getBounds: ss 10 + swap 20 + swap setBounds: ss moved: ss ; : contentClick \ New content click handler for fWind click: ss drop ; ' drawit setDraw: ss ' clicked dup setclick: ss setclick: bb : GO cls xts{ null null drawSS contentClick } actions: fWind bb addview: ss fWind setWindow: ss \ Normally done automatically from NEW: in Window+ new: ss \ Ditto 0 0 1000 1000 putPanRect: ss draw: ss ;